unit UnitTest;

interface

{$IFNDEF UNIT_TEST}
  {$MESSAGE FATAL 'UnitTest should be included only if UNIT_TEST is defined'}
{$ENDIF}

{$IFDEF UNIT_TEST}

uses
  Classes,
  SysUtils,
  Contnrs,
  SyncObjs,
  Windows;

type
  ITestingContext = interface
    function DoCheck(const v: Boolean; const msg: string = ''): Boolean;
    property Check[const v: Boolean; const msg: string = '']: Boolean read DoCheck; default;
  end;
  TTestProc = procedure(const t: ITestingContext);
  ITestLog = interface
    procedure Failured(const aTest: TTestProc; const aName: string; const log: string);
    procedure Accepted(const aName: string);
    procedure Finished;
  end;

function DefaultTestingContext: ITestingContext;  
procedure RegisterUnitTest(const p: TTestProc; const name: string = '');
procedure RunTests(const log: ITestLog; ThreadCount: Integer);

{$ENDIF}

implementation

{$IFDEF UNIT_TEST}

type
  TTestPair = class
  strict private
    fName: string;
    fTestProc: TTestProc;
  public
    constructor Create(p: TTestProc; const aName: string);
    property TestProc: TTestProc read fTestProc;
    property Name: string read fName;
  end;

  TGetNextTest = function(const Sender: ITestingContext): TTestPair of object;

  TSynchronizedLog = class(TInterfacedObject, ITestLog)
  strict private
    fCS: TCriticalSection;
    fLog: ITestLog;
  public
    constructor Create(const aLog: ITestLog);
    destructor Destroy; override;

    // ITestLog interface
    procedure Accepted(const aName: string);
    procedure Failured(const aTest: TTestProc; const aName: string; const log: string);
    procedure Finished;
  end;
  TSynchronizedTests = class;
  TSynchronizedTestEnumerator = class
  strict private
    fC: TTestPair;
    fOwner: TSynchronizedTests;
  public
    constructor Create(const owner: TSynchronizedTests);
    destructor Destroy; override;
    function MoveNext: Boolean;
    property Current: TTestPair read fC;  
  end;
  TSynchronizedTests = class
  private
    fTests: TObjectList;
    fCS: TCriticalSection;
    fInd: Integer;
    function GetNext: TTestPair;
  public
    constructor Create(const aTest: TObjectList);
    destructor Destroy; override;
    function GetEnumerator: TSynchronizedTestEnumerator;
  end;

  ITestResourceManager = interface
    ['{4CD7CCD2-C152-49CA-89B5-81FB93E4B038}']
  end;

  TTestThread = class(TThread, ITestingContext)
  strict private
    fRefCount: Integer;
    fTests: TSynchronizedTests;
    fLog: TSynchronizedLog;
    fOk: Boolean;
    fLogMessage: string;
    fResMan: ITestResourceManager;
    procedure AddToLog(const s: string); inline;
  protected
    procedure Execute; override;
    function DoCheck(const v: Boolean; const msg: string = ''): Boolean;
    function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
    class function NewInstance: TObject; override;
    constructor Create(const aLog: TSynchronizedLog; const aTests: TSynchronizedTests; const aResMan: ITestResourceManager);
    destructor Destroy; override;
    procedure Run;
  end;

  TTestResourceManager = class(TInterfacedObject, ITestResourceManager)
  strict private
    fTests: TSynchronizedTests;
    fLog: TSynchronizedLog;
  public
    constructor Create(const aTest: TSynchronizedTests; const aLog: TSynchronizedLog);
    destructor Destroy; override;
  end;

  TDefaultTestingContext = class(TInterfacedObject, ITestingContext)
  public
    function DoCheck(const v: Boolean; const msg: string = ''): Boolean;
  end;

var
  gTests: TObjectList;

procedure RegisterUnitTest(const p: TTestProc; const name: string);
begin
  gTests.Add(TTestPair.Create(p, name));
end;

function DefaultTestingContext: ITestingContext;
begin
  Result := TDefaultTestingContext.Create;
end;

procedure RunTests(const log: ITestLog; ThreadCount: Integer);
var
  lResMan: ITestResourceManager;
  lLog: TSynchronizedLog;
  lTests: TSynchronizedTests;
  th: TTestThread;
begin
  Assert(ThreadCount > 0);

  lLog := TSynchronizedLog.Create(log);
  lTests := TSynchronizedTests.Create(gTests);
  lResMan := TTestResourceManager.Create(lTests, lLog);

  while ThreadCount > 0 do
  begin
    th := TTestThread.Create(lLog, lTests, lResMan);
    th.Run;
    Dec(ThreadCount);
  end;
end;

{ TTestThread }

procedure TTestThread.AddToLog(const s: string);
begin
  if fLogMessage <> '' then
    fLogMessage := fLogMessage + sLineBreak + s
  else
    fLogMessage := s;
end;

procedure TTestThread.AfterConstruction;
begin
// Release the constructor's implicit refcount
  InterlockedDecrement(FRefCount);
end;

procedure TTestThread.BeforeDestruction;
begin
  if fRefCount <> 0 then
    System.Error(reInvalidPtr);
end;

constructor TTestThread.Create(const aLog: TSynchronizedLog; const aTests: TSynchronizedTests; const aResMan: ITestResourceManager);
begin
  Assert(Assigned(aTests) and Assigned(aLog) and Assigned(aResMan));
  
  inherited Create(True);
  FreeOnTerminate := True;
  fLogMessage := '';
  fLog := aLog;
  fTests := aTests;
  fResMan := aResMan;
end;

procedure TTestThread.Execute;
var
  t: TTestPair;
  lOk: Boolean;
begin
  for t in fTests do
  begin
    fLogMessage := '';
    AddToLog('TEST: ' + TTestPair(t).Name);
    lOk := True;
    try
      fOk := True;
      TTestPair(t).TestProc(Self);
      if not fOk then
        lOk := False;
    except
      on e: Exception do
      begin
        AddToLog('EXCEPTION [' + e.ClassName + ']: ' + e.Message);
        lOk := False;
      end;
    end;

    if lOk then
      fLog.Accepted(TTestPair(t).Name)
    else
       fLog.Failured(t.TestProc, t.Name, fLogMessage);
  end;
end;

class function TTestThread.NewInstance: TObject;
begin
  Result := inherited NewInstance;
  TTestThread(Result).fRefCount := 1;
end;

function TTestThread.QueryInterface(const IID: TGUID; out Obj): HRESULT;
begin
  if GetInterface(IID, Obj) then
    Result := 0
  else
    Result := E_NOINTERFACE;
end;

procedure TTestThread.Run;
begin
  inherited Resume;
end;

function TTestThread._AddRef: Integer;
begin
  Result := InterlockedIncrement(fRefCount);
end;

function TTestThread._Release: Integer;
begin
  Result := InterlockedDecrement(fRefCount);
  if Result = 0 then
    Destroy;
end;

destructor TTestThread.Destroy;
begin
  inherited;
end;

function TTestThread.DoCheck(const v: Boolean; const msg: string): Boolean;
begin
  if not v then
  begin
    fOk := False;
    if msg <> '' then
      AddToLog('   ' + msg)
    else
      AddToLog('   <no message>');
    AddToLog('');      
  end;
  Result := v;
end;

{ TSynhronizedLogEvent }

procedure TSynchronizedLog.Accepted(const aName: string);
begin
  fCS.Acquire;
  try
    fLog.Accepted(aName);
  finally
    fCS.Release;
  end;
end;

constructor TSynchronizedLog.Create(const aLog: ITestLog);
begin
  Assert(Assigned(aLog));
  fLog := aLog;
  fCS := TCriticalSection.Create;
end;

destructor TSynchronizedLog.Destroy;
begin
  fCS.Free;
  inherited;
end;

procedure TSynchronizedLog.Failured(const aTest: TTestProc; const aName: string; const log: string);
begin
  fCS.Acquire;
  try
    fLog.Failured(aTest, aName, log);
  finally
    fCS.Release;
  end;
end;

procedure TSynchronizedLog.Finished;
begin
  fCS.Acquire;
  try
    fLog.Finished;
  finally
    fCS.Release;
  end;
end;

{ TSynchronizedTestEnumerator }

constructor TSynchronizedTestEnumerator.Create(const owner: TSynchronizedTests);
begin
  Assert(Assigned(owner));
  fOwner := owner; 
end;

destructor TSynchronizedTestEnumerator.Destroy;
begin
  inherited;
end;

function TSynchronizedTestEnumerator.MoveNext: Boolean;
begin
  fC := fOwner.GetNext;
  Result := Assigned(fC);
end;

{ TSynchronizedTests }

constructor TSynchronizedTests.Create(const aTest: TObjectList);
begin
  Assert(Assigned(aTest));
  fTests := aTest;
  fCS := TCriticalSection.Create;
  fInd := -1;
end;

destructor TSynchronizedTests.Destroy;
begin
  fCS.Free;
  inherited;
end;

function TSynchronizedTests.GetEnumerator: TSynchronizedTestEnumerator;
begin
  Result := TSynchronizedTestEnumerator.Create(Self);
end;

function TSynchronizedTests.GetNext: TTestPair;
begin
  fCS.Enter;
  Inc(fInd);
  if fInd < fTests.Count then
    Result := TTestPair(fTests[fInd])
  else
    Result := nil;
  fCS.Leave;
end;

{ TTestPair }

constructor TTestPair.Create(p: TTestProc; const aName: string);
begin
  Assert(Assigned(p));
  fTestProc := p;
  fName := aName;
end;

{ TTestResourceDisposer }

constructor TTestResourceManager.Create(const aTest: TSynchronizedTests; const aLog: TSynchronizedLog);
begin
  Assert(Assigned(aTest) and Assigned(aLog));
  fTests := aTest;
  fLog := aLog;
end;

destructor TTestResourceManager.Destroy;
begin
  fLog.Finished;
  fTests.Free;
  fLog.Free;
  inherited;
end;

{ TDefaultTestingContext }

function TDefaultTestingContext.DoCheck(const v: Boolean; const msg: string): Boolean;
begin
  if v then
    Result := True
  else
    raise Exception.Create(msg);
end;

initialization
  gTests := TObjectList.Create(True);

finalization
  FreeAndNil(gTests);

{$ENDIF}

end.
